Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/misc/volume10/xlisp21/part03

Text File | 1990-02-26 | 49.3 KB | 1,891 lines

Newsgroups: comp.sources.misc
organization: Cognos Inc., Ottawa, Canada
subject: v10i090: XLisP 2.1 Sources 1c (3/3) / 5
From: [e-mail] (Gary Murphy)
Sender: [e-mail] (Brandon S. Allbery - comp.sources.misc)

Posting-number: Volume 10, Issue 90
Submitted-by: [e-mail] (Gary Murphy)
Archive-name: xlisp21/part03

#!/bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #!/bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
#    xlspeed.dif
# This archive created: Sun Feb 18 23:29:48 1990
# By:    Gary Murphy ()
export PATH; PATH=/bin:$PATH
echo shar: extracting "'xlspeed.dif'" '(47351 characters)'
if test -f 'xlspeed.dif'
then
    echo shar: over-writing existing file "'xlspeed.dif'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlspeed.dif'
XFrom sce!mitel!uunet!lll-winken!ames!haven!umd5!jonnyg Tue May 23 15:37:24 EDT 1989
XArticle: 91 of comp.lang.lisp.x
XPath: cognos!sce!mitel!uunet!lll-winken!ames!haven!umd5!jonnyg
XFrom: [e-mail] (Jon Greenblatt)
XNewsgroups: comp.lang.lisp.x
XSubject: Xlisp2.0 speedups... (Part 1 of 3)
XMessage-ID: <[e-mail]>
XDate: 18 May 89 16:58:56 GMT
XReply-To: [e-mail] (Jon Greenblatt)
XOrganization: University of Maryland, College Park
XLines: 910
X
XThe following are changes I have made to xlisp 2.0 source. Most of these
Xchanges produce considerable speed ups. This distribution is very
Xrough but maybe someone can wade through it and come of with a cleaned
Xup version of the speed ups. Note this is a striaght context diff so
Xmore than just the speed ups are included, BEWARE! If you are able to
Xclean up or enhance these speed ups in any way I would apreciate the
Xfeedback.
X
X                JonnyG.
X
Xdiff -c ../xlisp.org/xlbfun.c ../xlisp/xlbfun.c
X*** ../xlisp.org/xlbfun.c    Sun May  7 22:25:38 1989
X--- ../xlisp/xlbfun.c    Wed Apr  5 16:18:23 1989
X***************
X*** 558,563 ****
X--- 558,578 ----
X      return (val);
X  }
X
X+ LVAL xcopyarray()
X+ {
X+     LVAL src, dest;
X+     int num;
X+     register int i;
X+
X+     src = xlgavector();
X+     dest = xlgavector();
X+     xllastarg();
X+     num = (getsize(src) < getsize(dest)) ? getsize(src) : getsize(dest);
X+     for (i = 0; i < num; i++)
X+         setelement(dest,i,getelement(src,i));
X+     return(dest);
X+ }
X+
X  /* xerror - special form 'error' */
X  LVAL xerror()
X  {
Xdiff -c ../xlisp.org/xldbug.c ../xlisp/xldbug.c
X*** ../xlisp.org/xldbug.c    Sun May  7 22:25:43 1989
X--- ../xlisp/xldbug.c    Wed Apr  5 16:18:24 1989
X***************
X*** 14,20 ****
X  extern char buf[];
X
X  /* external routines */
X! extern char *malloc();
X
X  /* forward declarations */
X  FORWARD LVAL stacktop();
X--- 14,20 ----
X  extern char buf[];
X
X  /* external routines */
X! extern char *xlmalloc();
X
X  /* forward declarations */
X  FORWARD LVAL stacktop();
Xdiff -c ../xlisp.org/xldmem.c ../xlisp/xldmem.c
X*** ../xlisp.org/xldmem.c    Sun May  7 22:25:46 1989
X--- ../xlisp/xldmem.c    Wed Apr  5 16:18:25 1989
X***************
X*** 6,13 ****
X  #include "xlisp.h"
X
X  /* node flags */
X! #define MARK    1
X! #define LEFT    2
X
X  /* macro to compute the size of a segment */
X  #define segsize(n) (sizeof(SEGMENT)+((n)-1)*sizeof(struct node))
X--- 6,13 ----
X  #include "xlisp.h"
X
X  /* node flags */
X! #define MARK    0x20
X! #define LEFT    0x40
X
X  /* macro to compute the size of a segment */
X  #define segsize(n) (sizeof(SEGMENT)+((n)-1)*sizeof(struct node))
X***************
X*** 21,37 ****
X  SEGMENT *segs,*lastseg,*fixseg,*charseg;
X  int anodes,nsegs,gccalls;
X  long nnodes,nfree,total;
X! LVAL fnodes;
X
X  /* external procedures */
X! extern char *malloc();
X! extern char *calloc();
X
X  /* forward declarations */
X! FORWARD LVAL newnode();
X  FORWARD unsigned char *stralloc();
X  FORWARD SEGMENT *newsegment();
X
X  /* cons - construct a new cons node */
X  LVAL cons(x,y)
X    LVAL x,y;
X--- 21,50 ----
X  SEGMENT *segs,*lastseg,*fixseg,*charseg;
X  int anodes,nsegs,gccalls;
X  long nnodes,nfree,total;
X! LVAL fnodes = NIL;
X
X  /* external procedures */
X! extern char *xlmalloc();
X! extern char *xlcalloc();
X
X  /* forward declarations */
X! FORWARD LVAL Newnode();
X  FORWARD unsigned char *stralloc();
X  FORWARD SEGMENT *newsegment();
X
X+ LVAL _nnode;
X+ FIXTYPE _tfixed;
X+ int _tint;
X+
X+ #define    newnode(type) (((_nnode = fnodes) != NIL) ? \
X+             ((fnodes = cdr(_nnode)), \
X+              nfree--, \
X+              (_nnode->n_type = type), \
X+              rplacd(_nnode,NIL), \
X+              _nnode) \
X+             : (_nnode = Newnode(type)))
X+
X+
X  /* cons - construct a new cons node */
X  LVAL cons(x,y)
X    LVAL x,y;
X***************
X*** 129,140 ****
X  }
X
X  /* cvfixnum - convert an integer to a fixnum node */
X! LVAL cvfixnum(n)
X    FIXTYPE n;
X  {
X      LVAL val;
X-     if (n >= SFIXMIN && n <= SFIXMAX)
X-     return (&fixseg->sg_nodes[(int)n-SFIXMIN]);
X      val = newnode(FIXNUM);
X      val->n_fixnum = n;
X      return (val);
X--- 142,151 ----
X  }
X
X  /* cvfixnum - convert an integer to a fixnum node */
X! LVAL Cvfixnum(n)
X    FIXTYPE n;
X  {
X      LVAL val;
X      val = newnode(FIXNUM);
X      val->n_fixnum = n;
X      return (val);
X***************
X*** 151,157 ****
X  }
X
X  /* cvchar - convert an integer to a character node */
X! LVAL cvchar(n)
X    int n;
X  {
X      if (n >= CHARMIN && n <= CHARMAX)
X--- 162,168 ----
X  }
X
X  /* cvchar - convert an integer to a character node */
X! LVAL Cvchar(n)
X    int n;
X  {
X      if (n >= CHARMIN && n <= CHARMAX)
X***************
X*** 180,185 ****
X--- 191,225 ----
X      return (val);
X  }
X
X+ #ifdef    WINDOWS
X+ LVAL newwinobj(size)
X+ int size;
X+ {
X+     LVAL val;
X+     val = newnode(WINOBJ);
X+     if (size > 0) {
X+         xlprot1(val);
X+         if ((val->n_winobj = xldcalloc(1,size)) == NULL) {
X+             findmem();
X+             if ((val->n_winobj = xldcalloc(1,size)) == NULL)
X+                 xlfail("insufficient memory");
X+             }
X+         xlpop();
X+         }
X+     else val->n_winobj = NULL;
X+     return(val);
X+ }
X+
X+ LVAL cvwinobj(p)
X+ char *p;
X+     {
X+     LVAL val;
X+     val = newnode(WINOBJ);
X+     val->n_winobj = p;
X+     return(val);
X+     }
X+ #endif
X+
X  /* newclosure - allocate and initialize a new closure */
X  LVAL newclosure(name,type,env,fenv)
X    LVAL name,type,env,fenv;
X***************
X*** 204,212 ****
X      vect = newnode(VECTOR);
X      vect->n_vsize = 0;
X      if (bsize = size * sizeof(LVAL)) {
X!     if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL) {
X          findmem();
X!         if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL)
X          xlfail("insufficient vector space");
X      }
X      vect->n_vsize = size;
X--- 244,252 ----
X      vect = newnode(VECTOR);
X      vect->n_vsize = 0;
X      if (bsize = size * sizeof(LVAL)) {
X!     if ((vect->n_vdata = (LVAL *)xldcalloc(1,bsize)) == NULL) {
X          findmem();
X!         if ((vect->n_vdata = (LVAL *)xldcalloc(1,bsize)) == NULL)
X          xlfail("insufficient vector space");
X      }
X      vect->n_vsize = size;
X***************
X*** 217,223 ****
X  }
X
X  /* newnode - allocate a new node */
X! LOCAL LVAL newnode(type)
X    int type;
X  {
X      LVAL nnode;
X--- 257,263 ----
X  }
X
X  /* newnode - allocate a new node */
X! LVAL Newnode(type)
X    int type;
X  {
X      LVAL nnode;
X***************
X*** 248,256 ****
X      unsigned char *sptr;
X
X      /* allocate memory for the string copy */
X!     if ((sptr = (unsigned char *)malloc(size)) == NULL) {
X      gc();
X!     if ((sptr = (unsigned char *)malloc(size)) == NULL)
X          xlfail("insufficient string space");
X      }
X      total += (long)size;
X--- 288,296 ----
X      unsigned char *sptr;
X
X      /* allocate memory for the string copy */
X!     if ((sptr = (unsigned char *)xldmalloc(size)) == NULL) {
X      gc();
X!     if ((sptr = (unsigned char *)xldmalloc(size)) == NULL)
X          xlfail("insufficient string space");
X      }
X      total += (long)size;
X***************
X*** 330,336 ****
X    LVAL ptr;
X  {
X      register LVAL this,prev,tmp;
X!     int type,i,n;
X
X      /* initialize */
X      prev = NIL;
X--- 370,376 ----
X    LVAL ptr;
X  {
X      register LVAL this,prev,tmp;
X!     register int i,n;
X
X      /* initialize */
X      prev = NIL;
X***************
X*** 340,380 ****
X      for (;;) {
X
X      /* descend as far as we can */
X!     while (!(this->n_flags & MARK))
X
X          /* check cons and symbol nodes */
X!         if ((type = ntype(this)) == CONS) {
X!         if (tmp = car(this)) {
X!             this->n_flags |= MARK|LEFT;
X!             rplaca(this,prev);
X!         }
X!         else if (tmp = cdr(this)) {
X!             this->n_flags |= MARK;
X              rplacd(this,prev);
X!         }
X!         else {                /* both sides nil */
X!             this->n_flags |= MARK;
X              break;
X!         }
X!         prev = this;            /* step down the branch */
X!         this = tmp;
X!         }
X!
X!         /* mark other node types */
X          else {
X!         this->n_flags |= MARK;
X!         switch (type) {
X!         case SYMBOL:
X!         case OBJECT:
X!         case VECTOR:
X!         case CLOSURE:
X!             for (i = 0, n = getsize(this); --n >= 0; ++i)
X!             if (tmp = getelement(this,i))
X!                 mark(tmp);
X!             break;
X!         }
X!         break;
X!         }
X
X      /* backup to a point where we can continue descending */
X      for (;;)
X--- 380,409 ----
X      for (;;) {
X
X      /* descend as far as we can */
X!     while (!(this->n_type & MARK))
X
X          /* check cons and symbol nodes */
X!         if ((i = (this->n_type |= MARK) & TYPEFIELD) == CONS) {
X!           if (tmp = car(this)) {
X!             this->n_type |= LEFT;
X!             rplaca(this,prev);}
X!           else if (tmp = cdr(this))
X              rplacd(this,prev);
X!           else                /* both sides nil */
X              break;
X!           prev = this;            /* step down the branch */
X!           this = tmp;
X!           }
X          else {
X!           if ((i & ARRAY) != 0)
X!         for (i = 0, n = getsize(this); i < n;)
X!           if (tmp = getelement(this,i++))
X!             if ((tmp->n_type & (ARRAY|MARK)) == ARRAY ||
X!              tmp->n_type == CONS)
X!                 mark(tmp);
X!             else tmp->n_type |= MARK;
X!           break;
X!           }
X
X      /* backup to a point where we can continue descending */
X      for (;;)
X***************
X*** 381,388 ****
X
X          /* make sure there is a previous node */
X          if (prev) {
X!         if (prev->n_flags & LEFT) {    /* came from left side */
X!             prev->n_flags &= ~LEFT;
X              tmp = car(prev);
X              rplaca(prev,this);
X              if (this = cdr(prev)) {
X--- 410,417 ----
X
X          /* make sure there is a previous node */
X          if (prev) {
X!         if (prev->n_type & LEFT) {    /* came from left side */
X!             prev->n_type &= ~LEFT;
X              tmp = car(prev);
X              rplaca(prev,this);
X              if (this = cdr(prev)) {
X***************
X*** 399,406 ****
X          }
X
X          /* no previous node, must be done */
X!         else
X!         return;
X      }
X  }
X
X--- 428,434 ----
X          }
X
X          /* no previous node, must be done */
X!         else return;
X      }
X  }
X
X***************
X*** 407,434 ****
X  /* sweep - sweep all unmarked nodes and add them to the free list */
X  LOCAL sweep()
X  {
X!     SEGMENT *seg;
X!     LVAL p;
X!     int n;
X
X-     /* empty the free list */
X      fnodes = NIL;
X!     nfree = 0L;
X
X      /* add all unmarked nodes */
X      for (seg = segs; seg; seg = seg->sg_next) {
X!     if (seg == fixseg)     /* don't sweep the fixnum segment */
X          continue;
X-     else if (seg == charseg) /* don't sweep the character segment */
X-         continue;
X      p = &seg->sg_nodes[0];
X!     for (n = seg->sg_size; --n >= 0; ++p)
X!         if (!(p->n_flags & MARK)) {
X          switch (ntype(p)) {
X          case STRING:
X              if (getstring(p) != NULL) {
X                  total -= (long)getslength(p);
X!                 free(getstring(p));
X              }
X              break;
X          case STREAM:
X--- 435,463 ----
X  /* sweep - sweep all unmarked nodes and add them to the free list */
X  LOCAL sweep()
X  {
X!     register SEGMENT *seg;
X!     register LVAL p;
X!     register int n;
X
X      fnodes = NIL;
X!     nfree = 0l;
X
X      /* add all unmarked nodes */
X      for (seg = segs; seg; seg = seg->sg_next) {
X!     if (seg == fixseg || seg == charseg)
X!          /* don't sweep the fixed segments */
X          continue;
X      p = &seg->sg_nodes[0];
X!     for (n = seg->sg_size; --n >= 0;)
X!         if (p->n_type & MARK)
X!         (p++)->n_type &= ~MARK;
X!         else {
X          switch (ntype(p)) {
X          case STRING:
X              if (getstring(p) != NULL) {
X                  total -= (long)getslength(p);
X!            /* Using getstring here breaks VMEM (JonnyG) */
X!                 xldfree(p->n_string);
X              }
X              break;
X          case STREAM:
X***************
X*** 435,440 ****
X--- 464,474 ----
X              if (getfile(p))
X                  osclose(getfile(p));
X              break;
X+ #ifdef    WINDOWS
X+         case WINOBJ:
X+             free_winobj(p);
X+             break;
X+ #endif
X          case SYMBOL:
X          case OBJECT:
X          case VECTOR:
X***************
X*** 441,447 ****
X          case CLOSURE:
X              if (p->n_vsize) {
X                  total -= (long) (p->n_vsize * sizeof(LVAL));
X!                 free(p->n_vdata);
X              }
X              break;
X          }
X--- 475,481 ----
X          case CLOSURE:
X              if (p->n_vsize) {
X                  total -= (long) (p->n_vsize * sizeof(LVAL));
X!                 xldfree(p->n_vdata);
X              }
X              break;
X          }
X***************
X*** 448,458 ****
X          p->n_type = FREE;
X          rplaca(p,NIL);
X          rplacd(p,fnodes);
X!         fnodes = p;
X!         nfree += 1L;
X          }
X-         else
X-         p->n_flags &= ~MARK;
X      }
X  }
X
X--- 482,490 ----
X          p->n_type = FREE;
X          rplaca(p,NIL);
X          rplacd(p,fnodes);
X!         fnodes = p++;
X!         nfree++;
X          }
X      }
X  }
X
X***************
X*** 485,491 ****
X      SEGMENT *newseg;
X
X      /* allocate the new segment */
X!     if ((newseg = (SEGMENT *)calloc(1,segsize(n))) == NULL)
X      return (NULL);
X
X      /* initialize the new segment */
X--- 517,524 ----
X      SEGMENT *newseg;
X
X      /* allocate the new segment */
X!
X!     if ((newseg = (SEGMENT *)xlcalloc(1,segsize(n))) == NULL)
X      return (NULL);
X
X      /* initialize the new segment */
X***************
X*** 666,677 ****
X      s_gcflag = s_gchook = NIL;
X
X      /* allocate the evaluation stack */
X!     if ((xlstkbase = (LVAL **)malloc(EDEPTH * sizeof(LVAL *))) == NULL)
X      xlfatal("insufficient memory");
X      xlstack = xlstktop = xlstkbase + EDEPTH;
X
X      /* allocate the argument stack */
X!     if ((xlargstkbase = (LVAL *)malloc(ADEPTH * sizeof(LVAL))) == NULL)
X      xlfatal("insufficient memory");
X      xlargstktop = xlargstkbase + ADEPTH;
X      xlfp = xlsp = xlargstkbase;
X--- 699,710 ----
X      s_gcflag = s_gchook = NIL;
X
X      /* allocate the evaluation stack */
X!     if ((xlstkbase = (LVAL **)xlmalloc(EDEPTH * sizeof(LVAL *))) == NULL)
X      xlfatal("insufficient memory");
X      xlstack = xlstktop = xlstkbase + EDEPTH;
X
X      /* allocate the argument stack */
X!     if ((xlargstkbase = (LVAL *)xlmalloc(ADEPTH * sizeof(LVAL))) == NULL)
X      xlfatal("insufficient memory");
X      xlargstktop = xlargstkbase + ADEPTH;
X      xlfp = xlsp = xlargstkbase;
Xdiff -c ../xlisp.org/xldmem.h ../xlisp/xldmem.h
X*** ../xlisp.org/xldmem.h    Sun May  7 22:25:47 1989
X--- ../xlisp/xldmem.h    Wed Apr  5 16:45:38 1989
X***************
X*** 13,21 ****
X  #define CHARMAX        255
X  #define CHARSIZE    256
X
X- /* new node access macros */
X- #define ntype(x)    ((x)->n_type)
X-
X  /* cons access macros */
X  #define car(x)        ((x)->n_car)
X  #define cdr(x)        ((x)->n_cdr)
X--- 13,18 ----
X***************
X*** 23,72 ****
X  #define rplacd(x,y)    ((x)->n_cdr = (y))
X
X  /* symbol access macros */
X! #define getvalue(x)     ((x)->n_vdata[0])
X! #define setvalue(x,v)     ((x)->n_vdata[0] = (v))
X! #define getfunction(x)     ((x)->n_vdata[1])
X! #define setfunction(x,v) ((x)->n_vdata[1] = (v))
X! #define getplist(x)     ((x)->n_vdata[2])
X! #define setplist(x,v)     ((x)->n_vdata[2] = (v))
X! #define getpname(x)     ((x)->n_vdata[3])
X! #define setpname(x,v)     ((x)->n_vdata[3] = (v))
X  #define SYMSIZE        4
X
X  /* closure access macros */
X! #define getname(x)         ((x)->n_vdata[0])
X! #define setname(x,v)       ((x)->n_vdata[0] = (v))
X! #define gettype(x)        ((x)->n_vdata[1])
X! #define settype(x,v)      ((x)->n_vdata[1] = (v))
X! #define getargs(x)         ((x)->n_vdata[2])
X! #define setargs(x,v)       ((x)->n_vdata[2] = (v))
X! #define getoargs(x)        ((x)->n_vdata[3])
X! #define setoargs(x,v)      ((x)->n_vdata[3] = (v))
X! #define getrest(x)         ((x)->n_vdata[4])
X! #define setrest(x,v)       ((x)->n_vdata[4] = (v))
X! #define getkargs(x)        ((x)->n_vdata[5])
X! #define setkargs(x,v)      ((x)->n_vdata[5] = (v))
X! #define getaargs(x)        ((x)->n_vdata[6])
X! #define setaargs(x,v)      ((x)->n_vdata[6] = (v))
X! #define getbody(x)         ((x)->n_vdata[7])
X! #define setbody(x,v)       ((x)->n_vdata[7] = (v))
X! #define getenv(x)    ((x)->n_vdata[8])
X! #define setenv(x,v)    ((x)->n_vdata[8] = (v))
X! #define getfenv(x)    ((x)->n_vdata[9])
X! #define setfenv(x,v)    ((x)->n_vdata[9] = (v))
X! #define getlambda(x)    ((x)->n_vdata[10])
X! #define setlambda(x,v)    ((x)->n_vdata[10] = (v))
X  #define CLOSIZE        11
X
X  /* vector access macros */
X  #define getsize(x)    ((x)->n_vsize)
X! #define getelement(x,i)    ((x)->n_vdata[i])
X! #define setelement(x,i,v) ((x)->n_vdata[i] = (v))
X
X  /* object access macros */
X! #define getclass(x)    ((x)->n_vdata[0])
X! #define getivar(x,i)    ((x)->n_vdata[i+1])
X! #define setivar(x,i,v)    ((x)->n_vdata[i+1] = (v))
X
X  /* subr/fsubr access macros */
X  #define getsubr(x)    ((x)->n_subr)
X--- 20,69 ----
X  #define rplacd(x,y)    ((x)->n_cdr = (y))
X
X  /* symbol access macros */
X! #define getvalue(x)     (ACESSV(x,0))
X! #define setvalue(x,v)     (ACESSV(x,0) = (v))
X! #define getfunction(x)     (ACESSV(x,1))
X! #define setfunction(x,v) (ACESSV(x,1) = (v))
X! #define getplist(x)     (ACESSV(x,2))
X! #define setplist(x,v)     (ACESSV(x,2) = (v))
X! #define getpname(x)     (ACESSV(x,3))
X! #define setpname(x,v)     (ACESSV(x,3) = (v))
X  #define SYMSIZE        4
X
X  /* closure access macros */
X! #define getname(x)         (ACESSV(x,0))
X! #define setname(x,v)       (ACESSV(x,0) = (v))
X! #define gettype(x)        (ACESSV(x,1))
X! #define settype(x,v)      (ACESSV(x,1) = (v))
X! #define getargs(x)         (ACESSV(x,2))
X! #define setargs(x,v)       (ACESSV(x,2) = (v))
X! #define getoargs(x)        (ACESSV(x,3))
X! #define setoargs(x,v)      (ACESSV(x,3) = (v))
X! #define getrest(x)         (ACESSV(x,4))
X! #define setrest(x,v)       (ACESSV(x,4) = (v))
X! #define getkargs(x)        (ACESSV(x,5))
X! #define setkargs(x,v)      (ACESSV(x,5) = (v))
X! #define getaargs(x)        (ACESSV(x,6))
X! #define setaargs(x,v)      (ACESSV(x,6) = (v))
X! #define getbody(x)         (ACESSV(x,7))
X! #define setbody(x,v)       (ACESSV(x,7) = (v))
X! #define getenv(x)    (ACESSV(x,8))
X! #define setenv(x,v)    (ACESSV(x,8) = (v))
X! #define getfenv(x)    (ACESSV(x,9))
X! #define setfenv(x,v)    (ACESSV(x,9) = (v))
X! #define getlambda(x)    (ACESSV(x,10))
X! #define setlambda(x,v)    (ACESSV(x,10) = (v))
X  #define CLOSIZE        11
X
X  /* vector access macros */
X  #define getsize(x)    ((x)->n_vsize)
X! #define getelement(x,i)    (ACESSV(x,i))
X! #define setelement(x,i,v) (ACESSV(x,i) = (v))
X
X  /* object access macros */
X! #define getclass(x)    (ACESSV(x,0))
X! #define getivar(x,i)    (ACESSV(x,i+1))
X! #define setivar(x,i,v)    (ACESSV(x,i+1) = (v))
X
X  /* subr/fsubr access macros */
X  #define getsubr(x)    ((x)->n_subr)
X***************
X*** 78,84 ****
X  #define getchcode(x)    ((x)->n_chcode)
X
X  /* string access macros */
X! #define getstring(x)    ((x)->n_string)
X  #define getslength(x)    ((x)->n_strlen)
X
X  /* file stream access macros */
X--- 75,81 ----
X  #define getchcode(x)    ((x)->n_chcode)
X
X  /* string access macros */
X! #define getstring(x)    (ACESSS((x)->n_string))
X  #define getslength(x)    ((x)->n_strlen)
X
X  /* file stream access macros */
X***************
X*** 93,114 ****
X  #define gettail(x)    ((x)->n_cdr)
X  #define settail(x,v)    ((x)->n_cdr = (v))
X
X  /* node types */
X  #define FREE    0
X  #define SUBR    1
X  #define FSUBR    2
X  #define CONS    3
X! #define SYMBOL    4
X! #define FIXNUM    5
X! #define FLONUM    6
X! #define STRING    7
X! #define OBJECT    8
X! #define STREAM    9
X! #define VECTOR    10
X! #define CLOSURE    11
X! #define CHAR    12
X! #define USTREAM    13
X
X  /* subr/fsubr node */
X  #define n_subr        n_info.n_xsubr.xs_subr
X  #define n_offset    n_info.n_xsubr.xs_offset
X--- 90,121 ----
X  #define gettail(x)    ((x)->n_cdr)
X  #define settail(x,v)    ((x)->n_cdr = (v))
X
X+ #define    getwinobj(x)    (ACESSS((x)->n_winobj))
X+ #define    setwinobj(x,v)    ((x)->n_winobj = (v))
X+
X  /* node types */
X  #define FREE    0
X+ #define SYMBOL    17
X+ #define OBJECT    18
X+ #define VECTOR    19
X+ #define CLOSURE    20
X  #define SUBR    1
X  #define FSUBR    2
X  #define CONS    3
X! #define FIXNUM    4
X! #define FLONUM    5
X! #define STRING    6
X! #define STREAM    7
X! #define CHAR    8
X! #define USTREAM    9
X! #define    WINOBJ    10
X
X+ #define    ARRAY    16
X+ #define TYPEFIELD 0x1f
X+
X+ /* new node access macros */
X+ #define ntype(x)    ((x)->n_type & TYPEFIELD)
X+
X  /* subr/fsubr node */
X  #define n_subr        n_info.n_xsubr.xs_subr
X  #define n_offset    n_info.n_xsubr.xs_offset
X***************
X*** 137,146 ****
X  #define n_vsize        n_info.n_xvector.xv_size
X  #define n_vdata        n_info.n_xvector.xv_data
X
X  /* node structure */
X  typedef struct node {
X      char n_type;        /* type of node */
X-     char n_flags;        /* flag bits */
X      union ninfo {         /* value */
X      struct xsubr {        /* subr/fsubr node */
X          struct node *(*xs_subr)();    /* function pointer */
X--- 144,155 ----
X  #define n_vsize        n_info.n_xvector.xv_size
X  #define n_vdata        n_info.n_xvector.xv_data
X
X+ /* window/font node */
X+ #define    n_winobj    n_info.n_xwinobj.xw_ptr
X+
X  /* node structure */
X  typedef struct node {
X      char n_type;        /* type of node */
X      union ninfo {         /* value */
X      struct xsubr {        /* subr/fsubr node */
X          struct node *(*xs_subr)();    /* function pointer */
X***************
X*** 171,176 ****
X--- 180,188 ----
X          int xv_size;        /* vector size */
X          struct node **xv_data;    /* vector data */
X      } n_xvector;
X+     struct xwinobj {    /* window/font object */
X+         char *xw_ptr;        /* Generic structure pointer */
X+     } n_xwinobj;
X      } n_info;
X  } *LVAL;
X
X***************
X*** 187,195 ****
X  extern LVAL cvstring();           /* convert a string */
X  extern LVAL cvfile();        /* convert a FILE * to a file */
X  extern LVAL cvsubr();        /* convert a function to a subr/fsubr */
X! extern LVAL cvfixnum();           /* convert a fixnum */
X  extern LVAL cvflonum();           /* convert a flonum */
X! extern LVAL cvchar();        /* convert a character */
X
X  extern LVAL newstring();    /* create a new string */
X  extern LVAL newvector();    /* create a new vector */
X--- 199,207 ----
X  extern LVAL cvstring();           /* convert a string */
X  extern LVAL cvfile();        /* convert a FILE * to a file */
X  extern LVAL cvsubr();        /* convert a function to a subr/fsubr */
X! extern LVAL Cvfixnum();           /* convert a fixnum */
X  extern LVAL cvflonum();           /* convert a flonum */
X! extern LVAL Cvchar();        /* convert a character */
X
X  extern LVAL newstring();    /* create a new string */
X  extern LVAL newvector();    /* create a new vector */
X***************
X*** 196,198 ****
X--- 208,249 ----
X  extern LVAL newobject();    /* create a new object */
X  extern LVAL newclosure();    /* create a new closure */
X  extern LVAL newustream();    /* create a new unnamed stream */
X+
X+
X+ /* Speed ups, reduce function calls for fixed characters and numbers       */
X+ /* Speed is exeptionaly noticed on machines with large a instruction cache */
X+ /* No size effects here (JonnyG) */
X+
X+ extern SEGMENT *fixseg,*charseg;
X+ extern FIXTYPE _tfixed;
X+ extern int _tint;
X+
X+ #define cvfixnum(n) ((_tfixed = n), \
X+         ((_tfixed > SFIXMIN && _tfixed < SFIXMAX) ? \
X+         &fixseg->sg_nodes[(int)_tfixed-SFIXMIN] : \
X+         Cvfixnum(_tfixed)))
X+
X+ #define cvchar(c) ((_tint = c), \
X+         ((_tint >= CHARMIN && _tint <= CHARMIN) ? \
X+             &charseg->sg_nodes[_tint-CHARMIN] : \
X+         Cvchar(_tint)))
X+
X+ extern    char *xldmalloc();
X+ extern    char *xldcalloc();
X+
X+ #ifdef    VMEM
X+
X+ extern char *vload();
X+
X+ extern    unsigned char *vaccess();
X+
X+ #define    ACESSV(x,i)    (((LVAL *)vaccess((x)->n_vdata))[i])
X+ #define    ACESSS(x)    (vaccess(x))
X+
X+ #else
X+
X+ #define    xlfcalloc    xlcalloc
X+ #define ACESSV(x,i)    (x)->n_vdata[i]
X+ #define    ACESSS(x)    x
X+
X+ #endif
Xdiff -c ../xlisp.org/xlfio.c ../xlisp/xlfio.c
X*** ../xlisp.org/xlfio.c    Sun May  7 22:25:52 1989
X--- ../xlisp/xlfio.c    Wed Apr  5 16:18:27 1989
X***************
X*** 349,355 ****
X
X      /* copy the substring into the stream */
X      for (i = start; i < end; ++i)
X!     xlputc(val,str[i]);
X
X      /* restore the stack */
X      xlpop();
X--- 349,355 ----
X
X      /* copy the substring into the stream */
X      for (i = start; i < end; ++i)
X!     xlputc(val,getstring(string) + i);
X
X      /* restore the stack */
X      xlpop();
X***************
X*** 450,456 ****
X  LOCAL LVAL getstroutput(stream)
X    LVAL stream;
X  {
X!     unsigned char *str;
X      LVAL next,val;
X      int len,ch;
X
X--- 450,456 ----
X  LOCAL LVAL getstroutput(stream)
X    LVAL stream;
X  {
X!     int i;
X      LVAL next,val;
X      int len,ch;
X
X***************
X*** 462,471 ****
X      val = newstring(len + 1);
X
X      /* copy the characters into the new string */
X!     str = getstring(val);
X      while ((ch = xlgetc(stream)) != EOF)
X!     *str++ = ch;
X!     *str = '\0';
X
X      /* return the string */
X      return (val);
X--- 462,471 ----
X      val = newstring(len + 1);
X
X      /* copy the characters into the new string */
X!     i = 0;
X      while ((ch = xlgetc(stream)) != EOF)
X!     getstring(val)[i++] = ch;
X!     getstring(val)[i] = '\0';
X
X      /* return the string */
X      return (val);
X
X
XFrom sce!mitel!uunet!lll-winken!ames!haven!umd5!jonnyg Tue May 23 15:37:32 EDT 1989
XArticle: 92 of comp.lang.lisp.x
XPath: cognos!sce!mitel!uunet!lll-winken!ames!haven!umd5!jonnyg
XFrom: [e-mail] (Jon Greenblatt)
XNewsgroups: comp.lang.lisp.x
XSubject: Xlisp 2.0 speedups (Part 2 of 3)
XMessage-ID: <[e-mail]>
XDate: 18 May 89 16:59:37 GMT
XReply-To: [e-mail] (Jon Greenblatt)
XOrganization: University of Maryland, College Park
XLines: 913
X
Xdiff -c ../xlisp.org/xlftab.c ../xlisp/xlftab.c
X*** ../xlisp.org/xlftab.c    Sun May  7 22:25:54 1989
X--- ../xlisp/xlftab.c    Wed Apr  5 16:18:28 1989
X***************
X*** 11,17 ****
X      rmhash(),rmquote(),rmdquote(),rmbquote(),rmcomma(),
X      clnew(),clisnew(),clanswer(),
X      obisnew(),obclass(),obshow(),
X!     rmlpar(),rmrpar(),rmsemi(),
X      xeval(),xapply(),xfuncall(),xquote(),xfunction(),xbquote(),
X      xlambda(),xset(),xsetq(),xsetf(),xdefun(),xdefmacro(),
X      xgensym(),xmakesymbol(),xintern(),
X--- 11,17 ----
X      rmhash(),rmquote(),rmdquote(),rmbquote(),rmcomma(),
X      clnew(),clisnew(),clanswer(),
X      obisnew(),obclass(),obshow(),
X!     rmlpar(),rmrpar(),rmlbrace(),rmrbrace(),rmsemi(),
X      xeval(),xapply(),xfuncall(),xquote(),xfunction(),xbquote(),
X      xlambda(),xset(),xsetq(),xsetf(),xdefun(),xdefmacro(),
X      xgensym(),xmakesymbol(),xintern(),
X***************
X*** 70,76 ****
X      xcharp(),xcharint(),xintchar(),
X      xmkstrinput(),xmkstroutput(),xgetstroutput(),xgetlstoutput(),
X      xgetlambda(),xmacroexpand(),x1macroexpand(),
X!     xtrace(),xuntrace();
X
X  /* functions specific to xldmem.c */
X  LVAL xgc(),xexpand(),xalloc(),xmem();
X--- 70,76 ----
X      xcharp(),xcharint(),xintchar(),
X      xmkstrinput(),xmkstroutput(),xgetstroutput(),xgetlstoutput(),
X      xgetlambda(),xmacroexpand(),x1macroexpand(),
X!     xtrace(),xuntrace(),xcopyarray();
X
X  /* functions specific to xldmem.c */
X  LVAL xgc(),xexpand(),xalloc(),xmem();
X***************
X*** 90,96 ****
X
X  /* the function table */
X  FUNDEF funtab[] = {
X-
X      /* read macro functions */
X  {    NULL,                S, rmhash        }, /*   0 */
X  {    NULL,                S, rmquote        }, /*   1 */
X--- 90,95 ----
X***************
X*** 100,107 ****
X  {    NULL,                S, rmlpar        }, /*   5 */
X  {    NULL,                S, rmrpar        }, /*   6 */
X  {    NULL,                S, rmsemi        }, /*   7 */
X! {    NULL,                S, xnotimp        }, /*   8 */
X! {    NULL,                S, xnotimp        }, /*   9 */
X
X      /* methods */
X  {    NULL,                S, clnew        }, /*  10 */
X--- 99,106 ----
X  {    NULL,                S, rmlpar        }, /*   5 */
X  {    NULL,                S, rmrpar        }, /*   6 */
X  {    NULL,                S, rmsemi        }, /*   7 */
X! {    NULL,                S, rmlbrace        }, /*   8 */
X! {    NULL,                S, rmrbrace        }, /*   9 */
X
X      /* methods */
X  {    NULL,                S, clnew        }, /*  10 */
X***************
X*** 426,432 ****
X  {    "SORT",                S, xsort        }, /* 284 */
X
X      /* extra table entries */
X! {    NULL,                S, xnotimp        }, /* 285 */
X  {    NULL,                S, xnotimp        }, /* 286 */
X  {    NULL,                S, xnotimp        }, /* 287 */
X  {    NULL,                S, xnotimp        }, /* 288 */
X--- 425,431 ----
X  {    "SORT",                S, xsort        }, /* 284 */
X
X      /* extra table entries */
X! {    "COPY-ARRAY",            S, xcopyarray        }, /* 285 */
X  {    NULL,                S, xnotimp        }, /* 286 */
X  {    NULL,                S, xnotimp        }, /* 287 */
X  {    NULL,                S, xnotimp        }, /* 288 */
X***************
X*** 447,453 ****
X
X  {0,0,0} /* end of table marker */
X
X! };
X
X  /* xnotimp - function table entries that are currently not implemented */
X  LOCAL LVAL xnotimp()
X--- 446,452 ----
X
X  {0,0,0} /* end of table marker */
X
X! };
X
X  /* xnotimp - function table entries that are currently not implemented */
X  LOCAL LVAL xnotimp()
Xdiff -c ../xlisp.org/xlglob.c ../xlisp/xlglob.c
X*** ../xlisp.org/xlglob.c    Sun May  7 22:25:55 1989
X--- ../xlisp/xlglob.c    Wed Apr  5 16:18:28 1989
X***************
X*** 22,27 ****
X--- 22,28 ----
X  LVAL s_1plus=NIL,s_2plus=NIL,s_3plus=NIL;
X  LVAL s_1star=NIL,s_2star=NIL,s_3star=NIL;
X  LVAL s_minus=NIL,s_printcase=NIL;
X+ LVAL s_send=NIL,s_sendsuper=NIL;
X
X  /* keywords */
X  LVAL k_test=NIL,k_tnot=NIL;
Xdiff -c ../xlisp.org/xlimage.c ../xlisp/xlimage.c
X*** ../xlisp.org/xlimage.c    Sun May  7 22:25:57 1989
X--- ../xlisp/xlimage.c    Wed Apr  5 16:18:28 1989
X***************
X*** 22,28 ****
X  /* external procedures */
X  extern SEGMENT *newsegment();
X  extern FILE *osbopen();
X! extern char *malloc();
X
X  /* forward declarations */
X  OFFTYPE readptr();
X--- 22,28 ----
X  /* external procedures */
X  extern SEGMENT *newsegment();
X  extern FILE *osbopen();
X! extern char *xlmalloc();
X
X  /* forward declarations */
X  OFFTYPE readptr();
X***************
X*** 170,176 ****
X      case USTREAM:
X          p = cviptr(off);
X          p->n_type = type;
X-         p->n_flags = 0;
X          rplaca(p,cviptr(readptr()));
X          rplacd(p,cviptr(readptr()));
X          off += 2;
X--- 170,175 ----
X***************
X*** 192,198 ****
X          case VECTOR:
X          case CLOSURE:
X          max = getsize(p);
X!         if ((p->n_vdata = (LVAL *)malloc(max * sizeof(LVAL))) == NULL)
X              xlfatal("insufficient memory - vector");
X          total += (long)(max * sizeof(LVAL));
X          for (i = 0; i < max; ++i)
X--- 191,197 ----
X          case VECTOR:
X          case CLOSURE:
X          max = getsize(p);
X!         if ((p->n_vdata = (LVAL *)xlmalloc(max * sizeof(LVAL))) == NULL)
X              xlfatal("insufficient memory - vector");
X          total += (long)(max * sizeof(LVAL));
X          for (i = 0; i < max; ++i)
X***************
X*** 200,206 ****
X          break;
X          case STRING:
X          max = getslength(p);
X!         if ((p->n_string = (unsigned char *)malloc(max)) == NULL)
X              xlfatal("insufficient memory - string");
X          total += (long)max;
X          for (cp = getstring(p); --max >= 0; )
X--- 199,205 ----
X          break;
X          case STRING:
X          max = getslength(p);
X!         if ((p->n_string = (unsigned char *)xlmalloc(max)) == NULL)
X              xlfatal("insufficient memory - string");
X          total += (long)max;
X          for (cp = getstring(p); --max >= 0; )
X***************
X*** 247,257 ****
X          case VECTOR:
X          case CLOSURE:
X          if (p->n_vsize)
X!             free(p->n_vdata);
X          break;
X          case STRING:
X          if (getslength(p))
X!             free(getstring(p));
X          break;
X          case STREAM:
X          if ((fp = getfile(p)) && (fp != stdin && fp != stdout))
X--- 246,256 ----
X          case VECTOR:
X          case CLOSURE:
X          if (p->n_vsize)
X!             xlfree(p->n_vdata);
X          break;
X          case STRING:
X          if (getslength(p))
X!             xlfree(getstring(p));
X          break;
X          case STREAM:
X          if ((fp = getfile(p)) && (fp != stdin && fp != stdout))
X***************
X*** 259,265 ****
X          break;
X          }
X      next = seg->sg_next;
X!     free(seg);
X      }
X  }
X
X--- 258,264 ----
X          break;
X          }
X      next = seg->sg_next;
X!     xlfree(seg);
X      }
X  }
X
X***************
X*** 302,308 ****
X      char *p = (char *)&node->n_info;
X      int n = sizeof(union ninfo);
X      node->n_type = type;
X-     node->n_flags = 0;
X      while (--n >= 0)
X      *p++ = osbgetc(fp);
X  }
X--- 301,306 ----
Xdiff -c ../xlisp.org/xlinit.c ../xlisp/xlinit.c
X*** ../xlisp.org/xlinit.c    Sun May  7 22:25:59 1989
X--- ../xlisp/xlinit.c    Wed Apr  5 16:18:29 1989
X***************
X*** 27,32 ****
X--- 27,33 ----
X  extern LVAL a_fixnum,a_flonum,a_string,a_stream,a_object;
X  extern LVAL a_vector,a_closure,a_char,a_ustream;
X  extern LVAL s_gcflag,s_gchook;
X+ extern LVAL s_send,s_sendsuper;
X  extern FUNDEF funtab[];
X
X  /* xlinit - xlisp initialization routine */
X***************
X*** 106,111 ****
X--- 107,114 ----
X      s_eql    = xlenter("EQL");
X      s_ifmt    = xlenter("*INTEGER-FORMAT*");
X      s_ffmt    = xlenter("*FLOAT-FORMAT*");
X+     s_send    = xlenter("SEND");
X+     s_sendsuper = xlenter("SEND-SUPER");
X
X      /* symbols set by the read-eval-print loop */
X      s_1plus    = xlenter("+");
Xdiff -c ../xlisp.org/xlisp.c ../xlisp/xlisp.c
X*** ../xlisp.org/xlisp.c    Sun May  7 22:26:02 1989
X--- ../xlisp/xlisp.c    Thu Apr  6 10:06:46 1989
X***************
X*** 6,12 ****
X  #include "xlisp.h"
X
X  /* define the banner line string */
X! #define BANNER    "XLISP version 2.0, Copyright (c) 1988, by David Betz"
X
X  /* global variables */
X  jmp_buf top_level;
X--- 6,12 ----
X  #include "xlisp.h"
X
X  /* define the banner line string */
X! #define BANNER    "XLISP version 2.0w, Copyright (c) 1988, by David Betz"
X
X  /* global variables */
X  jmp_buf top_level;
X***************
X*** 52,60 ****
X          }
X  #endif
X
X      /* initialize and print the banner line */
X      osinit(BANNER);
X-
X      /* setup initialization error handler */
X      xlbegin(&cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,(LVAL)1);
X      if (setjmp(cntxt.c_jmpbuf))
X--- 52,63 ----
X          }
X  #endif
X
X+ #ifdef    X11
X+     parse_args(&argc,argv);
X+ #endif
X+
X      /* initialize and print the banner line */
X      osinit(BANNER);
X      /* setup initialization error handler */
X      xlbegin(&cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,(LVAL)1);
X      if (setjmp(cntxt.c_jmpbuf))
X***************
X*** 61,67 ****
X      xlfatal("fatal initialization error");
X      if (setjmp(top_level))
X      xlfatal("RESTORE not allowed during initialization");
X-
X      /* initialize xlisp */
X      xlinit();
X      xlend(&cntxt);
X--- 64,69 ----
Xdiff -c ../xlisp.org/xlisp.h ../xlisp/xlisp.h
X*** ../xlisp.org/xlisp.h    Sun May  7 22:26:12 1989
X--- ../xlisp/xlisp.h    Wed Apr  5 16:23:51 1989
X***************
X*** 4,10 ****
X      Permission is granted for unrestricted non-commercial use    */
X
X  /* system specific definitions */
X! /* #define UNIX */
X
X  #include <stdio.h>
X  #include <ctype.h>
X--- 4,11 ----
X      Permission is granted for unrestricted non-commercial use    */
X
X  /* system specific definitions */
X! #define X11
X! /* #define    ADEBUG */
X
X  #include <stdio.h>
X  #include <ctype.h>
X***************
X*** 24,29 ****
X--- 25,35 ----
X  /* OFFTYPE    number the size of an address (int) */
X
X  /* for the BSD 4.3 system.  Might work for AT&T garbage */
X+ #ifdef    X11
X+ #define    UNIX
X+ #define WINDOWS
X+ #endif
X+
X  #ifdef UNIX
X  #define NNODES        2000
X  #define SAVERESTORE
X***************
X*** 82,87 ****
X--- 88,105 ----
X  #define OFFTYPE        long
X  #endif
X
X+ #ifdef MSW
X+ #define NNODES        1000
X+ #define AFMT        "%lx"
X+ #define OFFTYPE        long
X+ #define    WINDOWS
X+ #define    VMEM
X+ #define    MSC
X+ #define    xlmalloc    WMalloc
X+ #define    xlcalloc    WCalloc
X+ #define    xlfree        WFree
X+ #endif
X+
X  /* for the Mark Williams C compiler - Atari ST */
X  #ifdef MWC
X  #define AFMT        "%lx"
X***************
X*** 148,153 ****
X--- 166,176 ----
X  #ifndef UCHAR
X  #define UCHAR        unsigned char
X  #endif
X+ #ifndef    xlmalloc
X+ #define    xlmalloc    malloc
X+ #define    xlcalloc    calloc
X+ #define    xlfree        free
X+ #endif
X
X  /* useful definitions */
X  #define TRUE    1
X***************
X*** 160,166 ****
X  #include "xldmem.h"
X
X  /* program limits */
X! #define STRMAX        100        /* maximum length of a string constant */
X  #define HSIZE        199        /* symbol hash table size */
X  #define SAMPLE        100        /* control character sample rate */
X
X--- 183,189 ----
X  #include "xldmem.h"
X
X  /* program limits */
X! #define STRMAX        512        /* maximum length of a string constant */
X  #define HSIZE        199        /* symbol hash table size */
X  #define SAMPLE        100        /* control character sample rate */
X
X***************
X*** 173,178 ****
X--- 196,203 ----
X  #define FT_RMLPAR    5
X  #define FT_RMRPAR    6
X  #define FT_RMSEMI    7
X+ #define    FT_RMLBRACE    8
X+ #define    FT_RMRBRACE    9
X  #define FT_CLNEW    10
X  #define FT_CLISNEW    11
X  #define FT_CLANSWER    12
X***************
X*** 179,191 ****
X  #define FT_OBISNEW    13
X  #define FT_OBCLASS    14
X  #define FT_OBSHOW    15
X!
X  /* macro to push a value onto the argument stack */
X  #define pusharg(x)    {if (xlsp >= xlargstktop) xlargstkoverflow();\
X!              *xlsp++ = (x);}
X
X  /* macros to protect pointers */
X! #define xlstkcheck(n)    {if (xlstack - (n) < xlstkbase) xlstkoverflow();}
X  #define xlsave(n)    {*--xlstack = &n; n = NIL;}
X  #define xlprotect(n)    {*--xlstack = &n;}
X
X--- 204,216 ----
X  #define FT_OBISNEW    13
X  #define FT_OBCLASS    14
X  #define FT_OBSHOW    15
X!
X  /* macro to push a value onto the argument stack */
X  #define pusharg(x)    {if (xlsp >= xlargstktop) xlargstkoverflow();\
X!              *(xlsp++) = (x);}
X
X  /* macros to protect pointers */
X! #define xlstkcheck(n)    {if ((xlstack - (n)) < xlstkbase) xlstkoverflow();}
X  #define xlsave(n)    {*--xlstack = &n; n = NIL;}
X  #define xlprotect(n)    {*--xlstack = &n;}
X
X***************
X*** 230,235 ****
X--- 255,261 ----
X  #define ustreamp(x)    ((x) && ntype(x) == USTREAM)
X  #define boundp(x)    (getvalue(x) != s_unbound)
X  #define fboundp(x)    (getfunction(x) != s_unbound)
X+ #define    winobjp(x)    ((x) && ntype(x) == WINOBJ)
X
X  /* shorthand functions */
X  #define consa(x)    cons(x,NIL)
X***************
X*** 323,326 ****
X  /* error reporting functions (don't *really* return at all) */
X  extern LVAL xltoofew();        /* report "too few arguments" error */
X  extern LVAL xlbadtype();    /* report "bad argument type" error */
X-
X--- 349,351 ----
Xdiff -c ../xlisp.org/xlobj.c ../xlisp/xlobj.c
X*** ../xlisp.org/xlobj.c    Sun May  7 22:26:20 1989
X--- ../xlisp/xlobj.c    Wed Apr  5 16:18:40 1989
X***************
X*** 41,47 ****
X  /* xsendsuper - send a message to the superclass of an object */
X  LVAL xsendsuper()
X  {
X!     LVAL env,p;
X      for (env = xlenv; env; env = cdr(env))
X      if ((p = car(env)) && objectp(car(p)))
X          return (sendmsg(car(p),
X--- 41,47 ----
X  /* xsendsuper - send a message to the superclass of an object */
X  LVAL xsendsuper()
X  {
X!     register LVAL env,p;
X      for (env = xlenv; env; env = cdr(env))
X      if ((p = car(env)) && objectp(car(p)))
X          return (sendmsg(car(p),
X***************
X*** 97,104 ****
X  int xlobgetvalue(pair,sym,pval)
X    LVAL pair,sym,*pval;
X  {
X!     LVAL cls,names;
X!     int ivtotal,n;
X
X      /* find the instance or class variable */
X      for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) {
X--- 97,104 ----
X  int xlobgetvalue(pair,sym,pval)
X    LVAL pair,sym,*pval;
X  {
X!     register LVAL cls,names;
X!     register int ivtotal,n;
X
X      /* find the instance or class variable */
X      for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) {
X***************
X*** 133,140 ****
X  int xlobsetvalue(pair,sym,val)
X    LVAL pair,sym,val;
X  {
X!     LVAL cls,names;
X!     int ivtotal,n;
X
X      /* find the instance or class variable */
X      for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) {
X--- 133,140 ----
X  int xlobsetvalue(pair,sym,val)
X    LVAL pair,sym,val;
X  {
X!     register LVAL cls,names;
X!     register int ivtotal,n;
X
X      /* find the instance or class variable */
X      for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) {
X***************
X*** 309,315 ****
X  LOCAL LVAL sendmsg(obj,cls,sym)
X    LVAL obj,cls,sym;
X  {
X!     LVAL msg,msgcls,method,val,p;
X
X      /* look for the message in the class or superclasses */
X      for (msgcls = cls; msgcls; ) {
X--- 309,316 ----
X  LOCAL LVAL sendmsg(obj,cls,sym)
X    LVAL obj,cls,sym;
X  {
X!     LVAL method,val;
X!     register LVAL msg,msgcls,p;
X
X      /* look for the message in the class or superclasses */
X      for (msgcls = cls; msgcls; ) {
X***************
X*** 316,322 ****
X
X      /* lookup the message in this class */
X      for (p = getivar(msgcls,MESSAGES); p; p = cdr(p))
X!         if ((msg = car(p)) && car(msg) == sym)
X          goto send_message;
X
X      /* look in class's superclass */
X--- 317,323 ----
X
X      /* lookup the message in this class */
X      for (p = getivar(msgcls,MESSAGES); p; p = cdr(p))
X!         if ((msg = car(p)) ? car(msg) == sym : 0)
X          goto send_message;
X
X      /* look in class's superclass */
X***************
X*** 363,369 ****
X  LOCAL LVAL evmethod(obj,msgcls,method)
X    LVAL obj,msgcls,method;
X  {
X!     LVAL oldenv,oldfenv,cptr,name,val;
X      CONTEXT cntxt;
X
X      /* protect some pointers */
X--- 364,370 ----
X  LOCAL LVAL evmethod(obj,msgcls,method)
X    LVAL obj,msgcls,method;
X  {
X!     LVAL oldenv,oldfenv,name,cptr,val;
X      CONTEXT cntxt;
X
X      /* protect some pointers */
X***************
X*** 420,428 ****
X
X  /* listlength - find the length of a list */
X  LOCAL int listlength(list)
X!   LVAL list;
X  {
X!     int len;
X      for (len = 0; consp(list); len++)
X      list = cdr(list);
X      return (len);
X--- 421,429 ----
X
X  /* listlength - find the length of a list */
X  LOCAL int listlength(list)
X! register LVAL list;
X  {
X!     register int len;
X      for (len = 0; consp(list); len++)
X      list = cdr(list);
X      return (len);
X***************
X*** 470,473 ****
X      xladdmsg(object,":CLASS",FT_OBCLASS);
X      xladdmsg(object,":SHOW",FT_OBSHOW);
X  }
X-
X--- 471,473 ----
Xdiff -c ../xlisp.org/xlprin.c ../xlisp/xlprin.c
X*** ../xlisp.org/xlprin.c    Sun May  7 22:26:23 1989
X--- ../xlisp/xlprin.c    Fri May  5 13:35:51 1989
X***************
X*** 33,38 ****
X--- 33,41 ----
X      case FSUBR:
X          putsubr(fptr,"FSubr",vptr);
X          break;
X+     case WINOBJ:
X+         putsymbol(fptr,"<Windows object>",flag);
X+         break;
X      case CONS:
X          xlputc(fptr,'(');
X          for (nptr = vptr; nptr != NIL; nptr = next) {
Xdiff -c ../xlisp.org/xlread.c ../xlisp/xlread.c
X*** ../xlisp.org/xlread.c    Sun May  7 22:26:26 1989
X--- ../xlisp/xlread.c    Wed Apr  5 16:18:41 1989
X***************
X*** 15,20 ****
X--- 15,21 ----
X  extern LVAL s_quote,s_function,s_bquote,s_comma,s_comat;
X  extern LVAL s_rtable,k_wspace,k_const,k_nmacro,k_tmacro;
X  extern LVAL k_sescape,k_mescape;
X+ extern LVAL s_send, s_sendsuper;
X  extern char buf[];
X
X  /* external routines */
X***************
X*** 29,35 ****
X  /* forward declarations */
X  FORWARD LVAL callmacro();
X  FORWARD LVAL psymbol(),punintern();
X! FORWARD LVAL pnumber(),pquote(),plist(),pvector();
X  FORWARD LVAL tentry();
X
X  /* xlload - load a file of xlisp expressions */
X--- 30,36 ----
X  /* forward declarations */
X  FORWARD LVAL callmacro();
X  FORWARD LVAL psymbol(),punintern();
X! FORWARD LVAL pnumber(),pquote(),plist(),pmessage(),pvector();
X  FORWARD LVAL tentry();
X
X  /* xlload - load a file of xlisp expressions */
X***************
X*** 366,371 ****
X--- 367,386 ----
X      return (consa(plist(fptr)));
X  }
X
X+ /* rmlbrace - read macro for '{' */
X+ LVAL rmlbrace()
X+ {
X+     LVAL fptr,mch;
X+
X+     /* get the file and macro character */
X+     fptr = xlgetfile();
X+     mch = xlgachar();
X+     xllastarg();
X+
X+     /* make the return value */
X+     return (consa(pmessage(fptr)));
X+ }
X+
X  /* rmrpar - read macro for ')' */
X  LVAL rmrpar()
X  {
X***************
X*** 372,377 ****
X--- 387,398 ----
X      xlfail("misplaced right paren");
X  }
X
X+ /* rmbrace - read macro for '}' */
X+ LVAL rmrbrace()
X+ {
X+     xlfail("misplaced right brace");
X+ }
X+
X  /* rmsemi - read macro for ';' */
X  LVAL rmsemi()
X  {
X***************
X*** 485,490 ****
X--- 506,555 ----
X      return (val);
X  }
X
X+ /* plist - parse a message */
X+ LOCAL LVAL pmessage(fptr)
X+   LVAL fptr;
X+ {
X+     LVAL val,expr,lastnptr,nptr;
X+     LVAL mess = s_send;
X+
X+     /* protect some pointers */
X+     xlstkcheck(2);
X+     xlsave(val);
X+     xlsave(expr);
X+
X+     if (nextch(fptr) == '+') { /* Look for super class message */
X+     mess = s_sendsuper;
X+     xlgetc(fptr);
X+     }
X+
X+     /* keep appending nodes until a closing paren is found */
X+     for (lastnptr = NIL; nextch(fptr) != '}'; )
X+
X+     /* get the next expression */
X+     if (readone(fptr,&expr) == EOF)
X+         badeof(fptr);
X+     else {
X+         nptr = consa(expr);
X+         if (lastnptr == NIL)
X+         val = nptr;
X+         else
X+         rplacd(lastnptr,nptr);
X+         lastnptr = nptr;
X+         }
X+
X+     /* skip the closing bracket */
X+     xlgetc(fptr);
X+
X+     val = cons(mess,val);
X+
X+     /* restore the stack */
X+     xlpopn(2);
X+
X+     /* return successfully */
X+     return (val);
X+ }
X+
X  /* pvector - parse a vector */
X  LOCAL LVAL pvector(fptr)
X    LVAL fptr;
X***************
X*** 807,811 ****
X--- 872,878 ----
X      defmacro('(', k_tmacro,FT_RMLPAR);
X      defmacro(')', k_tmacro,FT_RMRPAR);
X      defmacro(';', k_tmacro,FT_RMSEMI);
X+     defmacro('{', k_tmacro,FT_RMLBRACE);
X+     defmacro('}', k_tmacro,FT_RMRBRACE);
X  }
X
Xdiff -c ../xlisp.org/xlsym.c ../xlisp/xlsym.c
X*** ../xlisp.org/xlsym.c    Sun May  7 22:26:32 1989
X--- ../xlisp/xlsym.c    Wed Apr  5 16:18:43 1989
X***************
X*** 4,10 ****
X      Permission is granted for unrestricted non-commercial use    */
X
X  #include "xlisp.h"
X!
X  /* external variables */
X  extern LVAL obarray,s_unbound;
X  extern LVAL xlenv,xlfenv,xldenv;
X--- 4,11 ----
X      Permission is granted for unrestricted non-commercial use    */
X
X  #include "xlisp.h"
X! #undef HSIZE
X! #define HSIZE 399
X  /* external variables */
X  extern LVAL obarray,s_unbound;
X  extern LVAL xlenv,xlfenv,xldenv;
X***************
X*** 16,22 ****
X  LVAL xlenter(name)
X    char *name;
X  {
X!     LVAL sym,array;
X      int i;
X
X      /* check for nil */
X--- 17,24 ----
X  LVAL xlenter(name)
X    char *name;
X  {
X!     register LVAL sym,array;
X!     LVAL sym2;
X      int i;
X
X      /* check for nil */
X***************
X*** 31,44 ****
X          return (car(sym));
X
X      /* make a new symbol node and link it into the list */
X!     xlsave1(sym);
X!     sym = consd(getelement(array,i));
X!     rplaca(sym,xlmakesym(name));
X!     setelement(array,i,sym);
X      xlpop();
X-
X      /* return the new symbol */
X!     return (car(sym));
X  }
X
X  /* xlmakesym - make a new symbol node */
X--- 33,45 ----
X          return (car(sym));
X
X      /* make a new symbol node and link it into the list */
X!     xlsave1(sym2);
X!     sym2 = consd(getelement(array,i));
X!     rplaca(sym2,xlmakesym(name));
X!     setelement(array,i,sym2);
X      xlpop();
X      /* return the new symbol */
X!     return (car(sym2));
X  }
X
X  /* xlmakesym - make a new symbol node */
X***************
X*** 68,74 ****
X
X  /* xlxgetvalue - get the value of a symbol */
X  LVAL xlxgetvalue(sym)
X!   LVAL sym;
X  {
X      register LVAL fp,ep;
X      LVAL val;
X--- 69,75 ----
X
X  /* xlxgetvalue - get the value of a symbol */
X  LVAL xlxgetvalue(sym)
X! register LVAL sym;
X  {
X      register LVAL fp,ep;
X      LVAL val;
X***************
X*** 95,101 ****
X
X  /* xlsetvalue - set the value of a symbol */
X  xlsetvalue(sym,val)
X!   LVAL sym,val;
X  {
X      register LVAL fp,ep;
X
X--- 96,103 ----
X
X  /* xlsetvalue - set the value of a symbol */
X  xlsetvalue(sym,val)
X!   register LVAL sym;
X!   LVAL val;
X  {
X      register LVAL fp,ep;
X
X***************
X*** 137,143 ****
X
X  /* xlxgetfunction - get the functional value of a symbol */
X  LVAL xlxgetfunction(sym)
X!   LVAL sym;
X  {
X      register LVAL fp,ep;
X
X--- 139,145 ----
X
X  /* xlxgetfunction - get the functional value of a symbol */
X  LVAL xlxgetfunction(sym)
X! register  LVAL sym;
X  {
X      register LVAL fp,ep;
X
X***************
X*** 192,198 ****
X  xlremprop(sym,prp)
X    LVAL sym,prp;
X  {
X!     LVAL last,p;
X      last = NIL;
X      for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(last)) {
X      if (car(p) == prp)
X--- 194,200 ----
X  xlremprop(sym,prp)
X    LVAL sym,prp;
X  {
X!     register LVAL last,p;
X      last = NIL;
X      for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(last)) {
X      if (car(p) == prp)
X***************
X*** 208,214 ****
X  LOCAL LVAL findprop(sym,prp)
X    LVAL sym,prp;
X  {
X!     LVAL p;
X      for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
X      if (car(p) == prp)
X          return (cdr(p));
X--- 210,216 ----
X  LOCAL LVAL findprop(sym,prp)
X    LVAL sym,prp;
X  {
X!     register LVAL p;
X      for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
X      if (car(p) == prp)
X          return (cdr(p));
X***************
X*** 217,226 ****
X
X  /* hash - hash a symbol name string */
X  int hash(str,len)
X!   char *str;
X  {
X!     int i;
X!     for (i = 0; *str; )
X      i = (i << 2) ^ *str++;
X      i %= len;
X      return (i < 0 ? -i : i);
X--- 219,228 ----
X
X  /* hash - hash a symbol name string */
X  int hash(str,len)
X! register char *str;
X  {
X!     register int i = 0;
X!     while (*str)
X      i = (i << 2) ^ *str++;
X      i %= len;
X      return (i < 0 ? -i : i);
X
X
X
SHAR_EOF
if test 47351 -ne "`wc -c 'xlspeed.dif'`"
then
    echo shar: error transmitting "'xlspeed.dif'" '(should have been 47351 characters)'
fi
#    End of shell archive
exit 0
--
Gary Murphy                   uunet!mitel!sce!cognos!garym
                              ([e-mail])
[phone] x5537          Cognos Inc. P.O. Box 9707 Ottawa K1G 3N3
"There are many things which do not concern the process" - Joan of Arc